home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / File / Spec / Cygwin.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  3.3 KB  |  152 lines
  1. package File::Spec::Cygwin;
  2.  
  3. use strict;
  4. use vars qw(@ISA $VERSION);
  5. require File::Spec::Unix;
  6.  
  7. $VERSION = '3.2501';
  8.  
  9. @ISA = qw(File::Spec::Unix);
  10.  
  11. =head1 NAME
  12.  
  13. File::Spec::Cygwin - methods for Cygwin file specs
  14.  
  15. =head1 SYNOPSIS
  16.  
  17.  require File::Spec::Cygwin; # Done internally by File::Spec if needed
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  22. implementation of these methods, not the semantics.
  23.  
  24. This module is still in beta.  Cygwin-knowledgeable folks are invited
  25. to offer patches and suggestions.
  26.  
  27. =cut
  28.  
  29. =pod
  30.  
  31. =over 4
  32.  
  33. =item canonpath
  34.  
  35. Any C<\> (backslashes) are converted to C</> (forward slashes),
  36. and then File::Spec::Unix canonpath() is called on the result.
  37.  
  38. =cut
  39.  
  40. sub canonpath {
  41.     my($self,$path) = @_;
  42.     $path =~ s|\\|/|g;
  43.  
  44.     # Handle network path names beginning with double slash
  45.     my $node = '';
  46.     if ( $path =~ s@^(//[^/]+)(?:/|\z)@/@s ) {
  47.         $node = $1;
  48.     }
  49.     return $node . $self->SUPER::canonpath($path);
  50. }
  51.  
  52. sub catdir {
  53.     my $self = shift;
  54.  
  55.     # Don't create something that looks like a //network/path
  56.     if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
  57.         shift;
  58.         return $self->SUPER::catdir('', @_);
  59.     }
  60.  
  61.     $self->SUPER::catdir(@_);
  62. }
  63.  
  64. =pod
  65.  
  66. =item file_name_is_absolute
  67.  
  68. True is returned if the file name begins with C<drive_letter:>,
  69. and if not, File::Spec::Unix file_name_is_absolute() is called.
  70.  
  71. =cut
  72.  
  73.  
  74. sub file_name_is_absolute {
  75.     my ($self,$file) = @_;
  76.     return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test
  77.     return $self->SUPER::file_name_is_absolute($file);
  78. }
  79.  
  80. =item tmpdir (override)
  81.  
  82. Returns a string representation of the first existing directory
  83. from the following list:
  84.  
  85.     $ENV{TMPDIR}
  86.     /tmp
  87.     $ENV{'TMP'}
  88.     $ENV{'TEMP'}
  89.     C:/temp
  90.  
  91. Since Perl 5.8.0, if running under taint mode, and if the environment
  92. variables are tainted, they are not used.
  93.  
  94. =cut
  95.  
  96. my $tmpdir;
  97. sub tmpdir {
  98.     return $tmpdir if defined $tmpdir;
  99.     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", $ENV{'TMP'}, $ENV{'TEMP'}, 'C:/temp' );
  100. }
  101.  
  102. =item case_tolerant
  103.  
  104. Override Unix. Cygwin case-tolerance depends on managed mount settings and
  105. as with MsWin32 on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
  106. indicating the case significance when comparing file specifications.
  107. Default: 1
  108.  
  109. =cut
  110.  
  111. sub case_tolerant () {
  112.   if ($^O ne 'cygwin') {
  113.     return 1;
  114.   }
  115.   my $drive = shift;
  116.   if (! $drive) {
  117.       my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
  118.       my $prefix = pop(@flags);
  119.       if (! $prefix || $prefix eq 'cygdrive') {
  120.           $drive = '/cygdrive/c';
  121.       } elsif ($prefix eq '/') {
  122.           $drive = '/c';
  123.       } else {
  124.           $drive = "$prefix/c";
  125.       }
  126.   }
  127.   my $mntopts = Cygwin::mount_flags($drive);
  128.   if ($mntopts and ($mntopts =~ /,managed/)) {
  129.     return 0;
  130.   }
  131.   eval { require Win32API::File; } or return 1;
  132.   my $osFsType = "\0"x256;
  133.   my $osVolName = "\0"x256;
  134.   my $ouFsFlags = 0;
  135.   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
  136.   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
  137.   else { return 1; }
  138. }
  139.  
  140. =back
  141.  
  142. =head1 COPYRIGHT
  143.  
  144. Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
  145.  
  146. This program is free software; you can redistribute it and/or modify
  147. it under the same terms as Perl itself.
  148.  
  149. =cut
  150.  
  151. 1;
  152.